view release on metacpan or  search on metacpan

script/torrent  view on Meta::CPAN

}

# ─── Peer ID ──────────────────────────────────────────────────────────────────

sub generate_peer_id {
    return '-PL0001-' . join('', map { chr(int(rand(256))) } 1 .. 12);
}

# ─── Bitfield Helpers (MSB-first per BitTorrent spec) ─────────────────────────
# BitTorrent protocol: high bit of first byte = piece 0
# Perl's vec() uses LSB-first, so we use manual bit ops instead.

sub bf_has {
    my ($bf, $idx) = @_;
    my $byte_idx = int($idx / 8);
    my $bit = 7 - ($idx % 8);
    return 0 if $byte_idx >= length($bf);
    return (ord(substr($bf, $byte_idx, 1)) >> $bit) & 1;
}

sub bf_set {
    my ($bf_ref, $idx) = @_;
    my $byte_idx = int($idx / 8);
    my $bit = 7 - ($idx % 8);
    return if $byte_idx >= length($$bf_ref);
    substr($$bf_ref, $byte_idx, 1) =
        chr(ord(substr($$bf_ref, $byte_idx, 1)) | (1 << $bit));
}

# ─── Compact Peers Parsing ────────────────────────────────────────────────────

sub parse_compact_peers {
    my ($data) = @_;
    my @peers;
    return \@peers unless defined $data;

    if (ref $data eq 'ARRAY') {
        for my $p (@$data) {
            push @peers, { ip => $p->{ip}, port => $p->{port} };
        }
    } else {
        for (my $i = 0; $i + 6 <= length($data); $i += 6) {
            my @ip   = unpack('C4', substr($data, $i, 4));
            my $port = unpack('n',  substr($data, $i + 4, 2));
            push @peers, { ip => join('.', @ip), port => $port };
        }
    }
    return \@peers;
}

# ─── Tracker Communication ────────────────────────────────────────────────────

sub contact_tracker {
    my ($announce, $info_hash, $peer_id, $left, $event) = @_;

    my $sep = ($announce =~ /\?/) ? '&' : '?';
    my $url = $announce . $sep
        . 'info_hash='  . uri_escape($info_hash, "^A-Za-z0-9\\-_.!~*'()")
        . '&peer_id='   . uri_escape($peer_id,   "^A-Za-z0-9\\-_.!~*'()")
        . '&port=6881'
        . '&uploaded=0'
        . '&downloaded=0'
        . '&left=' . $left
        . '&compact=1';
    $url .= "&event=$event" if $event;

    print "  Contacting: $announce\n";

    my $ua   = LWP::UserAgent->new(timeout => 15);
    my $resp = $ua->get($url);
    unless ($resp->is_success) {
        warn "  Tracker request failed: " . $resp->status_line . "\n";
        return undef;
    }

    my $decoded = eval { bdecode($resp->content) };
    if ($@) {
        warn "  Failed to decode tracker response: $@\n";
        return undef;
    }
    if ($decoded->{'failure reason'}) {
        warn "  Tracker failure: " . $decoded->{'failure reason'} . "\n";
        return undef;
    }
    return $decoded;
}

# ─── Socket I/O ───────────────────────────────────────────────────────────────

sub read_exactly {
    my ($socket, $length) = @_;
    my $sel  = IO::Select->new($socket);
    my $data = '';
    my $remaining = $length;

    while ($remaining > 0) {
        return undef unless $sel->can_read(PEER_TIMEOUT);
        my $buf;
        my $n = sysread($socket, $buf, $remaining);
        return undef unless defined $n && $n > 0;
        $data .= $buf;
        $remaining -= $n;
    }
    return $data;
}

# ─── Peer Wire Protocol ──────────────────────────────────────────────────────

sub do_handshake {
    my ($socket, $info_hash, $peer_id) = @_;

    my $pstr      = 'BitTorrent protocol';
    my $handshake = chr(length($pstr)) . $pstr . ("\0" x 8) . $info_hash . $peer_id;

    my $n = syswrite($socket, $handshake);
    return undef unless defined $n && $n == length($handshake);

    my $response = read_exactly($socket, 68);
    return undef unless defined $response && length($response) == 68;

    my $resp_pstr = substr($response, 1, 19);