/ 
Net-BitTorrent-0.052
⭐ Starred 13 / t/700_classes/Net/BitTorrent/Peer.t
Security Advisories (4)
CVE-2026-57079 (2026-06-30)

Net::BitTorrent versions before 2.1.0 for Perl write files outside the download directory via path traversal in peer-supplied metadata. Net::BitTorrent validates file path components only on the .torrent-file ingest path. The peer and magnet metadata path (_on_metadata_received, reached from the BEP09 ut_metadata extension) passes attacker-supplied file names straight to Storage::add_file and Storage::_parse_file_tree, where Path::Tiny's child() does not collapse "..". A v2 file tree key, a v1 files[].path element, or a single-file name containing ".." segments therefore resolves outside the download directory. Because the peer also controls the piece hashes and the served bytes, content verification passes, so a malicious magnet or peer writes attacker-chosen content to an attacker-chosen path on the downloading host.

CVE-2026-57080 (2026-06-30)

Net::BitTorrent versions through 2.1.0 for Perl allow remote memory exhaustion via an uncapped peer-wire message-length prefix. The peer-wire framing in _process_messages trusts the 4-byte length prefix sent by a connected peer with no upper bound, while receive_data appends every inbound byte to the input buffer. A peer announces a length prefix of up to about 4 GiB and then streams bytes; the decoder waits until the buffer holds the full message before processing it, so the buffer grows without limit. Peer connections are unauthenticated, so any peer in the swarm exhausts the downloading process's memory. The largest legitimate message is a 16 KiB piece block, so any announced length far above that is anomalous.

CVE-2026-57081 (2026-06-30)

Net::BitTorrent versions through 2.1.0 for Perl allow remote memory exhaustion via deeply nested bencoded input. bdecode recurses once per nested list or dictionary level with no depth cap, and each recursive call receives the remaining buffer by value while the list and dictionary branches capture the whole remainder, so every live recursion frame keeps its own copy of the shrinking buffer (O(N^2) bytes for an N-deep input). The decoder runs on every untrusted bencode source: .torrent files, BEP09 metadata fetched from peers, DHT messages, and tracker responses. A bencoded input of roughly 150,000 nested lists (about 150 KB on the wire) drives multi-gigabyte peak memory, so one short message from any peer, or one crafted .torrent file or magnet link, terminates the client.

CVE-2026-57082 (2026-06-30)

Net::BitTorrent versions before 2.1.0 for Perl generate the MSE Diffie-Hellman private key with a non-cryptographic PRNG. The MSE (Message Stream Encryption) handshake derives its 160-bit Diffie-Hellman private key from Perl's rand(), a non-cryptographic drand48-class generator seeded once per process, in KeyExchange.pm. The shared secret and the RC4 keys derived from it (the SHA-1 of "keyA" or "keyB", the shared secret, and the infohash) therefore depend entirely on a predictable PRNG. The same handshake sends, in cleartext, random padding drawn from the same rand() sequence in _random_pad, immediately after the public key and the private-key draw. A passive observer of the handshake recovers the PRNG state from the cleartext padding, reconstructs the private key, computes the shared secret from the peer's public key on the wire, derives the RC4 keys, and decrypts the connection, defeating the passive-observation obfuscation MSE provides.

ok( $client->on_event(
        q[peer_read],
        sub {
            my ($self, $args) = @_;
            is($self, $client,
                q[Correct args passed to 'peer_read' [$_[0]]]);
            isa_ok($args->{q[Peer]}, q[Net::BitTorrent::Peer],
                   q[  ... [$_[1]->{'Peer'}]]);
            like($args->{q[Length]}, qr[^\d+$],
                 q[  ... [$_[1]->{'Length'}]]);
            my $peer = $args->{q[Peer]};
            delete $args->{q[Peer]};
            my $_len = $args->{q[Length]};
            delete $args->{q[Length]};
            is_deeply($args, {}, q[  ... No other keys in $_[1]]);
            warn(sprintf(q[Read %d bytes from '%s'],
                         $_len, $peer->as_string
                 )
            );
        }
    ),
    q[Installed 'peer_read' event handler]
);
ok( $client->on_event(
        q[peer_write],
        sub {
            my ($self, $args) = @_;
            is($self, $client,
                q[Correct args passed to 'peer_read' [$_[0]]]);
            isa_ok($args->{q[Peer]}, q[Net::BitTorrent::Peer],
                   q[  ... [$_[1]->{'Peer'}]]);
            like($args->{q[Length]}, qr[^\d+$],
                 q[  ... [$_[1]->{'Length'}]]);
            my $peer = $args->{q[Peer]};
            delete $args->{q[Peer]};
            my $_len = $args->{q[Length]};
            delete $args->{q[Length]};
            is_deeply($args, {}, q[  ... No other keys in $_[1]]);
            warn(sprintf(q[Wrote %d bytes from '%s'],
                         $_len, $peer->as_string
                 )
            );
        }
    ),
    q[Installed 'peer_write' event handler]
);
ok( $client->on_event(
        q[peer_disconnect],
        sub {
            my ($self, $args) = @_;
            is($self, $client,
                q[Correct args passed to 'peer_disconnect' [$_[0]]]);
            isa_ok($args->{q[Peer]}, q[Net::BitTorrent::Peer],
                   q[  ... [$_[1]->{'Peer'}]]);
            ok(defined($args->{q[Reason]}), q[  ... [$_[1]->{'Reason'}]]);
            my $peer = $args->{q[Peer]};
            delete $args->{q[Peer]};
            my $_why = $args->{q[Reason]};
            delete $args->{q[Reason]};
            is_deeply($args, {}, q[  ... No other keys in $_[1]]);
            warn(sprintf(q[Disconnected from '%s'%s],
                         $peer->as_string,
                         ($_why
                          ? (q[ (] . $_why . q[)])
                          : q[]
                         )
                 )
            );
        }
    ),
    q[Installed 'peer_disconnect' event handler]
);
ok( $client->on_event(
        q[peer_connect],
        sub {
            my ($self, $args) = @_;
            is($self, $client,
                q[Correct args passed to 'peer_connect' [$_[0]]]);
            isa_ok($args->{q[Peer]}, q[Net::BitTorrent::Peer],
                   q[  ... [$_[1]->{'Peer'}]]);
            my $peer = $args->{q[Peer]};
            delete $args->{q[Peer]};
            is_deeply($args, {}, q[  ... No other keys in $_[1]]);
            like($peer->_host . q[:] . $peer->_port,
                 qr[127.0.0.1:\d+],
                 sprintf q[%s connection %s '%s'],
                 ($peer->_incoming ? q[Incoming] : q[Outgoing]),
                 ($peer->_incoming ? q[from]     : q[to]),
                 $peer->as_string
            );
            return 1;
        }
    ),
    q[Installed 'peer_connect' event handler]
);
my @request_offsets = qw[0     16384 0     16384 16344 16354];
my @request_lengths = qw[16384 16384 16384 16384 16384 46384];
my @cancel_offsets  = reverse @request_offsets;
my @indexes         = (0 .. 10);                                 # have
ok( $client->on_event(
        q[incoming_packet],
        sub {
            my ($self, $args) = @_;
            my $type    = $args->{q[Type]};
            my $peer    = $args->{q[Peer]};
            my $payload = $args->{q[Payload]};
            if ($type eq KEEPALIVE) {
                warn q[TODO: keepalive];
            }
            elsif ($type == HANDSHAKE) {
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_handshake' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                is(scalar(keys %{$args->{'Payload'}}),
                    3, q[  ... scalar(keys %{$payload})]);
                is(length($args->{'Payload'}{q[Reserved]}),
                    8, q[  ... reserved conforms to spec]);
                is(length($args->{'Payload'}{q[Infohash]}),
                    20, q[  ... infohash conforms to spec]);
                is(length($args->{'Payload'}{q[PeerID]}),
                    20, q[  ... peerid conforms to spec]);
                delete $args->{q[Peer]};
                my $_len = $args->{q[Payload]};
                delete $args->{q[Payload]};
                is_deeply($args,
                          {Type => HANDSHAKE},
                          q[  ... No other keys in $_[1]]);

                if (   ($peer->peerid eq q[B] x 20)
                    or ($peer->peerid eq q[C] x 20)
                    or ($peer->peerid eq q[UNKNOWN-------------]))
                {   pass(sprintf q[PeerID is okay (%s)], $peer->peerid);
                }
                elsif ($peer->peerid eq $self->peerid) {
                    pass(sprintf q[Peerid match: %s eq %s],
                         $self->peerid, $peer->peerid);
                }
                else {
                    die(sprintf q[Unknown peerid: %s], $peer->peerid);
                }
            }
            elsif ($type == CHOKE) {
                my ($self, $args) = @_;
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_choke' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Payload => {}, Type => CHOKE},
                          q[  ... No other keys in $_[1]]);
                is($peer->peerid, q[C] x 20, q[Choked by 'CC..CC']);
            }
            elsif ($type == UNCHOKE) {
                my ($self, $args) = @_;
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_unchoke' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Payload => {}, Type => UNCHOKE},
                          q[  ... No other keys in $_[1]]);
                is($peer->peerid, q[C] x 20, q[Unchoked by 'CC..CC']);
            }
            elsif ($type == INTERESTED) {
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_unchoke' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Payload => {}, Type => INTERESTED},
                          q[  ... No other keys in $_[1]]);
                warn(
                    sprintf(q[%s is interested in me], $peer->as_string));
            }
            elsif ($type == NOT_INTERESTED) {
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_unchoke' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Payload => {}, Type => NOT_INTERESTED},
                          q[  ... No other keys in $_[1]]);
                warn(
                    sprintf(q[%s is interested in me], $peer->as_string));
            }
            elsif ($type == HAVE) {
                delete $_[1]->{q[Peer]};
                is_deeply(\@_,
                          [$client,
                           {Payload => {Index => shift(@indexes)},
                            Type    => HAVE
                           }
                          ],
                          q[Correct arguments passed to 'packet_incoming_have' event handler]
                );
                if ($peer->peerid eq q[C] x 20) {
                    if ($payload->{q[Index]} == 0) {
                        pass(q[Good peer has i:0]);
                    }
                    elsif ($payload->{q[Index]} == 1) {
                        pass(q[Good peer has i:1]);
                    }
                    else {
                        die(sprintf q[Peer claims to have %d],
                             $payload->{q[Index]});
                    }
                }
                else {
                    die(sprintf q[Unknown peer '%s' has %d],
                         $peer->peerid, $args->{q[Index]});
                }
            }
            elsif ($type == BITFIELD) {
                is($self, $client,
                    q[Correct args passed to 'packet_incoming_bitfield' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Type    => BITFIELD,
                           Payload => {}
                          },
                          q[  ... No other keys in $_[1]]
                );
                if (   ($peer->peerid eq q[B] x 20)
                    or ($peer->peerid eq q[C] x 20))
                {   pass(sprintf q[PeerID is okay (%s)], $peer->peerid);
                }
                elsif ($peer->peerid eq $self->peerid) {
                    pass(sprintf q[Peerid match: %s eq %s],
                         $self->peerid, $peer->peerid);
                }
                else {
                    die(sprintf q[Unknown peerid: %s], $peer->peerid);
                }
                warn(sprintf(q[Bitfield from %s], $peer->as_string));
            }
            elsif ($type == REQUEST) {
                warn sprintf q[%s is requesting [I:%4d O:%6d L:%6d]],
                    $peer->as_string,
                    $payload->{q[Index]},
                    $payload->{q[Offset]},
                    $payload->{q[Length]};
            }
            elsif ($type == PIECE) {
                delete $_[1]->{q[Peer]};
                is_deeply(\@_,
                          [$client,
                           {Payload => {Index  => 0,
                                        Length => 16384,
                                        Offset => 0
                            },
                            Type => PIECE
                           }
                          ],
                          q[Correct args passed to 'packet_incoming_block' event handler]
                );
                is($peer->_torrent->downloaded,
                    16384, q[Torrent downloaded amount updated]);
                warn(
                    sprintf
                        q[%s sent us [I:%4d O:%6d L:%6d] I have now downloaded %d bytes],
                    $peer->as_string,      $payload->{q[Index]},
                    $payload->{q[Offset]}, $payload->{q[Length]},
                    $peer->_torrent->downloaded
                );
            }
            elsif ($type == CANCEL) {
                ok( 1,
                    sprintf q[%s has canceled [I:%4d O:%6d L:%6d]],
                    $peer->as_string,
                    $args->{q[Index]},
                    $args->{q[Offset]},
                    $args->{q[Length]}
                );
            }
            elsif ($type == HAVE_ALL) {
                ok(1, sprintf q[%s says they have everything],
                    $peer->as_string);
            }
            elsif ($type == HAVE_NONE) {
                ok(1, sprintf q[%s says they have nothing],
                    $peer->as_string);
            }
            else { die q[Unhandled packet: ] . $type }
        }
    ),
    q[Installed 'incoming_packet' event handler (TODO)]
);
ok( $client->on_event(
        q[outgoing_packet],
        sub {
            my ($self, $args) = @_;
            my $type    = $args->{q[Type]};
            my $peer    = $args->{q[Peer]};
            my $payload = $args->{q[Payload]};
            if ($type == HANDSHAKE) {
                is($self, $client,
                    q[Correct args passed for outgoing handshake [$_[0]]]
                );
                isa_ok($peer, q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]);
                is(scalar(keys %{$payload}),
                    3, q[  ... scalar(@{$payload})]);
                is(length($payload->{q[Reserved]}), 8,
                    q[  ... [length($payload->{q[Reserved]}) ==  8] (reserved)]
                );
                is(length($payload->{q[Infohash]}), 20,
                    q[  ... [length($payload->{q[Infohash]}) == 20] (infohash)]
                );
                is(length($payload->{q[PeerID]}), 20,
                    q[  ... [length($payload->{q[PeerID]}) == 20] (peerid)]
                );
                delete $args->{q[Peer]};
                my $_len = $args->{q[Payload]};
                delete $args->{q[Payload]};
                is_deeply($args,
                          {Type => HANDSHAKE},
                          q[  ... No other keys in $_[1]]);

                if ($peer->_incoming) {
                    if (   ($peer->peerid eq q[B] x 20)
                        or ($peer->peerid eq q[C] x 20)
                        or ($peer->peerid eq q[UNKNOWN-------------]))
                    {   pass(sprintf q[PeerID is okay (%s)],
                             $peer->peerid);
                    }
                    elsif ($peer->peerid eq $self->peerid) {
                        pass(sprintf q[Peerid match: %s eq %s],
                             $self->peerid, $peer->peerid);
                    }
                    else {
                        die(sprintf q[Unknown peerid: %s],
                             $peer->peerid);
                    }
                }
            }
            elsif ($type == UNCHOKE) {
                my ($self, $args) = @_;
                is($self, $client,
                    q[Correct args passed to 'outgoing unchoke' [$_[0]]]);
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Payload => {}, Type => UNCHOKE},
                          q[  ... No other keys in $_[1]]);
                warn(sprintf(q[Unchoking %s], $peer->as_string));
            }
            elsif ($type == REQUEST) {
                warn(sprintf q[Requesting [I:%4d O:%6d L:%6d] from %s],
                     $payload->{q[Index]},  $payload->{q[Offset]},
                     $payload->{q[Length]}, $peer->as_string
                );
                is($self, $client,
                    q[Correct args passed to 'outgoing request' [$_[0]]]);
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                like($args->{q[Payload]}{q[Index]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Index'}]]);
                delete $args->{q[Payload]}{q[Index]};
                like($args->{q[Payload]}{q[Offset]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Offset'}]]);
                delete $args->{q[Payload]}{q[Offset]};
                like($args->{q[Payload]}{q[Length]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Length'}]]);
                delete $args->{q[Payload]}{q[Length]};
                is_deeply($args,
                          {Payload => {}, Type => REQUEST},
                          q[Correct args passed to 'outgoing request' event handler]
                );
            }
            elsif ($type == CANCEL) {
                is($self, $client,
                    q[Correct args passed to 'outgoing cancel' [$_[0]]]);
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                like($args->{q[Payload]}{q[Index]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Index'}]]);
                delete $args->{q[Payload]}{q[Index]};
                like($args->{q[Payload]}{q[Offset]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Offset'}]]);
                delete $args->{q[Payload]}{q[Offset]};
                like($args->{q[Payload]}{q[Length]},
                     qr[^\d+$], q[  ... [$_[1]->{'Payload'}{'Length'}]]);
                delete $args->{q[Payload]}{q[Length]};
                is_deeply($args,
                          {Payload => {}, Type => CANCEL},
                          q[Correct args passed to 'outgoing cancel' event handler]
                );
                warn(sprintf q[Canceling [I:%4d O:%6d L:%6d] from %s],
                     $payload->{q[Index]},  $payload->{q[Offset]},
                     $payload->{q[Length]}, $peer->as_string
                );
            }
            elsif ($type == PIECE) {
                warn sprintf
                    q[Sending [I:%4d O:%6d L:%6d] to %s. I have now uploaded %d bytes],
                    $payload->{q[Index]},
                    $payload->{q[Offset]},
                    $payload->{q[Length]},
                    $peer->as_string,
                    $peer->_torrent->uploaded;
            }
            elsif ($type == INTERESTED) {
                my ($self, $args) = @_;
                is($self, $client,
                    q[Correct args passed to 'outgoing interested' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Type => INTERESTED, Payload => {}},
                          q[  ... No other keys in $_[1]]);
                warn(sprintf(q[I am interested in %s], $peer->as_string));
            }
            elsif ($type == CHOKE) {
                warn sprintf q[ ===> Choking %s], $peer->as_string;
            }
            elsif ($type == BITFIELD) {
                is($self, $client,
                    q[Correct args passed to 'outgoing bitfield' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Type => BITFIELD},
                          q[  ... No other keys in $_[1]]);
                warn(sprintf(q[Sent bitfield to %s], $peer->as_string));
            }
            elsif ($type == HAVE_NONE) {
                is($self, $client,
                    q[Correct args passed to 'outgoing have none' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                is_deeply($args,
                          {Type => HAVE_NONE, Payload => {}},
                          q[  ... No other keys in $_[1]]);
            }
            elsif ($type == EXTPROTOCOL) {
                is($self, $client,
                    q[Correct args passed to 'outgoing extended protocol' [$_[0]]]
                );
                isa_ok($args->{q[Peer]},
                       q[Net::BitTorrent::Peer],
                       q[  ... [$_[1]->{'Peer'}]]
                );
                delete $args->{q[Peer]};
                delete $args->{q[Payload]};
                delete $args->{q[ID]};
                is_deeply($args,
                          {Type => EXTPROTOCOL},
                          q[  ... No other keys in $_[1]]);
            }
            else { warn q[****************** Unhandled packet: ] . $type }
        }
    ),
    q[Installed 'outgoing_packet' event handler]
);
ok( $client->on_event(
        q[ip_filter],
        sub {
            my ($self, $args) = @_;
            is($self, $client,
                q[Correct params passed to 'ip_filter' ($_[0])]);
        TODO: {
                local $TODO = q[Temporary DHT boot node breaks this test];
                like(
                    $args->{q[Address]},   # XXX - removed for DHT testing
                    qr[^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}:\d+$],
                    q[  ... ($_[1]->{'Address'})]
                );
            }
            my $address = $args->{'Address'};
            delete $args->{'Address'};
            is_deeply(
                $args,
                {},
                q[Correct params passed to 'ip_filter' (  ... No other keys in $_[1])]
            );
            warn(sprintf(q[Check IP filter for %s], $address));
            return 1;
        }
    ),
    q[Installed 'ip_filter' event handler]
);
warn sprintf q[%d|%d], 7, $test_builder->{q[Curr_Test]};
warn(q[Net::BitTorrent::Peer->new() requires params...]);
is(Net::BitTorrent::Peer->new(),   undef, q[No params]);
is(Net::BitTorrent::Peer->new({}), undef, q[Empty hashref]);
is(Net::BitTorrent::Peer->new({Socket => undef}),
    undef, q[Socket => undef]);
is(Net::BitTorrent::Peer->new({Socket => 0}), undef, q[Socket => 0]);
is(Net::BitTorrent::Peer->new({Socket => bless {}, q[GLOB]}),
    undef, q[Missing Client]);
is( Net::BitTorrent::Peer->new({Socket => bless({}, q[GLOB]), Client => 0}
    ),
    undef,
    q[Client => 0]
);
is( Net::BitTorrent::Peer->new({Socket => bless(\{}, q[GLOB]),
                                Client => bless(\{}, q[junk])
                               }
    ),
    undef,
    q[Client => bless \{}, 'junk']
);
warn sprintf q[%d|%d], 14, $test_builder->{q[Curr_Test]};
warn(q[For this next bit, we're testing outgoing peers...]);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => $torrent,
                                Address => q[junk]
                               }
    ),
    undef,
    q[Address => 'junk']
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => $torrent,
                                Address => undef
                               }
    ),
    undef,
    q[Address => undef]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[Missing Torrent]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => undef,
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[Torrent => undef]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => 0,
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[Torrent => 0]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => 'junk',
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[Torrent => 'junk']
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => bless(\{}, 'junk'),
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[Torrent => bless(\{}, 'junk')]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => $torrent,
                                Address => q[127.0.0.1:0]
                               }
    ),
    undef,
    q[No Source]
);
is( Net::BitTorrent::Peer->new({Client  => $client,
                                Torrent => $torrent,
                                Address => q[127.0.0.1:0],
                                Source  => undef
                               }
    ),
    undef,
    q[Source => undef]
);
warn sprintf q[%d|%d], 21, $test_builder->{q[Curr_Test]};
warn(q[Test incoming peers]);
{
    $peers{q[A]} =
        Net::BitTorrent::Peer->new({Client  => $client,
                                    Torrent => $torrent,
                                    Address => q[127.0.0.1:0],
                                    Source  => q[User]
                                   }
        );
    isa_ok($peers{q[A]}, q[Net::BitTorrent::Peer], q[new()]);
    weaken $peers{q[A]};
    ok(isweak($peers{q[A]}),    q[  ...make $peers{q[A]} a weak ref]);
    ok($peers{q[A]}->as_string, q[as_string]);
    is($peers{q[A]}->as_string,
        $peers{q[A]}->as_string(0),
        q[as_string() vs as_string(0)]);
    isn't($peers{q[A]}->as_string,
          $peers{q[A]}->as_string(1),
          q[as_string() vs as_string(1)]);
    sub TIEHANDLE { pass(q[Tied STDERR]); bless \{}, shift; }

    sub PRINT {
        is((caller(0))[0],
            q[Net::BitTorrent::Peer], q[String written to STDERR]);
    }
    sub UNTIE { pass(q[Untied STDERR]); }
    tie(*STDERR, __PACKAGE__);
    $peers{q[A]}->as_string;
    $peers{q[A]}->as_string(1);
    untie *STDERR;
    isa_ok($peers{q[A]}->_socket, q[GLOB], q[_socket]);
    isa_ok($peers{q[A]}->_torrent,
           q[Net::BitTorrent::Torrent], q[_torrent]);
    is($peers{q[A]}->_bitfield,     "\0", q[_bitfield]);
    is($peers{q[A]}->_peer_choking, 1,    q[Default peer_choking status]);
    is($peers{q[A]}->_am_choking,   1,    q[Default am_choking status]);
    is($peers{q[A]}->_peer_interested,
        0, q[Default peer_interested status]);
    is($peers{q[A]}->_am_interested, 0, q[Default am_interested status]);
    is($peers{q[A]}->_incoming,      0, q[Direction status is correct.]);
    warn sprintf q[%d|%d], 39, $test_builder->{q[Curr_Test]};
}
{
    my $newsock_A = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 44, $test_builder->{q[Curr_Test]};
    is( syswrite($newsock_A,
                 build_handshake(chr(0) x 8, q[A] x 20, q[B] x 20)
        ),
        68,
        q[Sent handshake to client]
    );
    my $with_peer = scalar keys %{$client->_connections};
    is(syswrite($newsock_A, build_bitfield(chr(1))),
        6, q[Sent bitfield to client]);
    is(syswrite($newsock_A, build_bitfield(chr(0))),
        6, q[Sent bitfield to client]);
    is(syswrite($newsock_A, build_bitfield(chr(0))),
        6, q[Sent bitfield to client]);
    is(syswrite($newsock_A, build_bitfield(chr(0))),
        6, q[Sent bitfield to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ok(($with_peer > scalar keys %{$client->_connections}),
        q[Peer removed from list of connections]);
    warn sprintf q[%d|%d], 71, $test_builder->{q[Curr_Test]};
}
{
    my $newsock_B = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is( syswrite($newsock_B,
                 build_handshake(chr(0) x 8,
                                 pack(q[H40], $torrent->infohash),
                                 $client->peerid
                 )
        ),
        68,
        q[Sent handshake to client]
    );
    my $with_peer = scalar keys %{$client->_connections};
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ok(($with_peer > scalar keys %{$client->_connections}),
        q[Peer removed from list of connections]);
    warn sprintf q[%d|%d], 99, $test_builder->{q[Curr_Test]};
}
{
    my $newsock_C = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is( syswrite($newsock_C,
                 build_handshake(chr(0) x 8,
                                 pack(q[H40], $torrent->infohash),
                                 q[C] x 20
                 )
        ),
        68,
        q[Sent handshake to client]
    );
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ($peers{q[C]}) = map {
        (    $_->{q[Object]}->isa(q[Net::BitTorrent::Peer])
         and defined $_->{q[Object]}->peerid
         and ($_->{q[Object]}->peerid eq q[C] x 20))
            ? $_->{q[Object]}
            : ()
    } values %{$client->_connections};
    weaken $peers{q[C]};
    ok(isweak($peers{q[C]}), q[  ...make $peers{q[C]} a weak ref]);
    warn sprintf q[%d|%d], 131, $test_builder->{q[Curr_Test]};
    like(${$peers{q[C]}}, qr[127.0.0.1:\d+],
         q[Address properly resolved]);
    is($peers{q[C]}->_host, q[127.0.0.1], q[_host]);
    like($peers{q[C]}->_port, qr[^\d+$], q[_port]);
    is($peers{q[C]}->peerid, q[C] x 20, q[PeerID check]);
    isa_ok($peers{q[C]}->_socket, q[GLOB], q[Socket stored properly]);
    warn sprintf q[%d|%d], 136, $test_builder->{q[Curr_Test]};
    is($peers{q[C]}->_am_choking,      1, q[Initial outgoing choke]);
    is($peers{q[C]}->_peer_choking,    1, q[Initial incoming choke]);
    is($peers{q[C]}->_am_interested,   0, q[Initial outgoing interest]);
    is($peers{q[C]}->_peer_interested, 0, q[Initial incoming interest]);

    ok(syswrite($newsock_C, build_interested), q[Incoming interested]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is($peers{q[C]}->_peer_interested, 1, q[Peer is interested]);

    ok(syswrite($newsock_C, build_unchoke), q[Incoming unchoke]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is($peers{q[C]}->_peer_choking, 0, q[Peer has unchoked us]);
    warn sprintf q[%d|%d], 172, $test_builder->{q[Curr_Test]};

    ok(syswrite($newsock_C, build_choke), q[Incoming choke]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is($peers{q[C]}->_peer_choking,
        1, q[Post-choke incoming choke status]);
    is($peers{q[C]}->_am_interested,
        0, q[Post-choke outgoing interest status]);
    warn sprintf q[%d|%d], 184, $test_builder->{q[Curr_Test]};
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is($peers{q[C]}->_am_choking,
        0, q[Post-interested outgoing choke status]);
    warn sprintf q[%d|%d], 186, $test_builder->{q[Curr_Test]};
    is($peers{q[C]}->_peer_choking,
        1, q[Post-interested incoming choke status]);
    is($peers{q[C]}->_am_interested,
        0, q[Post-interested outgoing interest status]);
    $client->do_one_loop(0);
    is($peers{q[C]}->_peer_interested,
        1, q[Post-interested incoming interest status]);
    warn sprintf q[%d|%d], 189, $test_builder->{q[Curr_Test]};
    ok(shutdown($newsock_C, 2),
        q[Peer closes socket. Leaving us hanging.]);
    my $with_peer = scalar keys %{$client->_connections};
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ok(($with_peer > scalar keys %{$client->_connections}),
        q[Peer removed from list of connections]);
    warn sprintf q[%d|%d], 196, $test_builder->{q[Curr_Test]};
}
{
    my $newsock_D = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is( syswrite($newsock_D,
                 build_handshake(qq[\0\0\0\0\0\20\0\4],
                                 pack(q[H40], $torrent->infohash),
                                 q[C] x 20
                 )
        ),
        68,
        q[Sent handshake to client]
    );
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    my $data = q[];

    #ok(sysread($newsock_D, $data, 68), q[Read handshake reply]);
    warn sprintf q[%d|%d], 233, $test_builder->{q[Curr_Test]};
    is(syswrite($newsock_D, build_keepalive()),
        4, q[Sent keepalive to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_D, build_unchoke()),
        5, q[Sent unchoke to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 253, $test_builder->{q[Curr_Test]};
    is(syswrite($newsock_D, build_choke()), 5, q[Sent choke to client]);
    is(syswrite($newsock_D, build_not_interested()),
        5, q[Sent not interested to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_D, build_have(0)), 9, q[Sent have to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ok(sysread($newsock_D, $data, 1024, length $data), q[Read]);
    warn sprintf q[%d|%d], 279, $test_builder->{q[Curr_Test]};
    is(syswrite($newsock_D, build_unchoke()),
        5, q[Sent unchoke to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    ok(sysread($newsock_D, $data, 1024, length $data), q[Read]);
    my $fake_piece = q[A] x 16384;
    is(syswrite($newsock_D, build_piece(0, 0, \$fake_piece)),
        16397, q[Sent piece i:0 o:0 l:16384 to client]);
    warn sprintf q[%d|%d], 307, $test_builder->{q[Curr_Test]};
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_D, build_choke()), 5, q[Sent choke to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_D, build_unchoke()),
        5, q[Sent choke to client to read second unchoke]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 344, $test_builder->{q[Curr_Test]};
    $flux_capacitor = 0.5;
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 349, $test_builder->{q[Curr_Test]};
    $flux_capacitor = 1;
    ok($client->do_one_loop(3), q[    do_one_loop(3)]);
    ok(sysread($newsock_D, $data, 1024, length $data), q[Read]);
    warn sprintf q[%d|%d], 351, $test_builder->{q[Curr_Test]};
    ok(syswrite($newsock_D, build_keepalive()), q[Write keepalive]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_D, build_interested()),
        5, q[Sent interested to client]);
    $flux_capacitor = 2.5;
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);

    #is(sysread($newsock_D, my ($in), 1024),
    #    undef, q[Fail to read data because socket was closed.]);
    #ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn q[TODO: Test multithreaded stuff...];
}
{
    my $newsock_E = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is( syswrite($newsock_E,
                 build_handshake(qq[\0\0\0\0\0\0\0\4],
                                 pack(q[H40], $torrent->infohash),
                                 q[UNKNOWN-------------]
                 )
        ),
        68,
        q[Sent handshake to client]
    );
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_E, build_have_all()),
        5, q[Sent HAVEALL to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 425, $test_builder->{q[Curr_Test]};
}
{
    my $newsock_F = newsock($client);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is( syswrite($newsock_F,
                 build_handshake(qq[\0\0\0\0\0\0\0\4],
                                 pack(q[H40], $torrent->infohash),
                                 q[UNKNOWN-------------]
                 )
        ),
        68,
        q[Sent handshake to client]
    );
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    is(syswrite($newsock_F, build_have_none()),
        5, q[Sent HAVEALL to client]);
    ok($client->do_one_loop(1), q[    do_one_loop(1)]);
    warn sprintf q[%d|%d], 474, $test_builder->{q[Curr_Test]};
}

1 POD Error

The following errors were encountered while parsing the POD:

Around line 709:

Unknown directive: =old