view release on metacpan or  search on metacpan

script/torrent  view on Meta::CPAN

    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);
    return undef unless $resp_pstr eq 'BitTorrent protocol';

    my $resp_info_hash = substr($response, 28, 20);
    unless ($resp_info_hash eq $info_hash) {
        warn "  Info hash mismatch in handshake\n";
        return undef;
    }
    return substr($response, 48, 20);    # peer's peer_id
}

sub send_msg {
    my ($socket, $id, $payload) = @_;
    $payload //= '';
    my $msg     = pack('N', 1 + length($payload)) . chr($id) . $payload;
    my $written = 0;
    while ($written < length($msg)) {
        my $n = syswrite($socket, $msg, length($msg) - $written, $written);
        return 0 unless defined $n;
        $written += $n;
    }
    return 1;
}

sub read_msg {
    my ($socket) = @_;

    my $len_buf = read_exactly($socket, 4);
    return undef unless defined $len_buf;

    my $len = unpack('N', $len_buf);
    return [ undef, '' ] if $len == 0;    # keep-alive

    # Sanity check: reject absurdly large messages
    return undef if $len > 2 * BLOCK_SIZE + 64;

    my $msg = read_exactly($socket, $len);
    return undef unless defined $msg && length($msg) == $len;

    return [ ord(substr($msg, 0, 1)), substr($msg, 1) ];
}

# ─── Piece Helpers ────────────────────────────────────────────────────────────

sub get_piece_length {
    my ($index, $nominal, $total) = @_;
    my $start     = $index * $nominal;
    my $remaining = $total - $start;
    return $remaining < $nominal ? $remaining : $nominal;
}

sub get_piece_hashes {
    my ($pieces_str) = @_;
    my @h;
    for (my $i = 0; $i < length($pieces_str); $i += 20) {
        push @h, substr($pieces_str, $i, 20);
    }
    return \@h;
}

# ─── Download a single piece with pipelined requests ─────────────────────────

sub download_piece {
    my ($socket, $piece_idx, $piece_length, $total_size,
        $peer_bf_ref, $peer_choking_ref) = @_;

    my $plen    = get_piece_length($piece_idx, $piece_length, $total_size);
    my $nblocks = ceil($plen / BLOCK_SIZE);
    my $requested = 0;
    my @block_done = (0) x $nblocks;
    my $received   = 0;
    my $piece_data = "\0" x $plen;

    while ($received < $nblocks) {
        # Send pipelined requests up to MAX_BACKLOG
        while (!$$peer_choking_ref
               && $requested < $nblocks
               && ($requested - $received) < MAX_BACKLOG) {
            my $offset = $requested * BLOCK_SIZE;
            my $blen = ($offset + BLOCK_SIZE > $plen)
                ? ($plen - $offset) : BLOCK_SIZE;
            send_msg($socket, MSG_REQUEST,
                     pack('NNN', $piece_idx, $offset, $blen));
            $requested++;
        }

        # Receive a message
        my $msg = read_msg($socket);
        return (0, undef) unless defined $msg;

        my ($id, $payload) = @$msg;
        next unless defined $id;    # keep-alive

        if ($id == MSG_CHOKE) {
            $$peer_choking_ref = 1;
            return (0, undef);

        } elsif ($id == MSG_UNCHOKE) {
            $$peer_choking_ref = 0;

        } elsif ($id == MSG_HAVE) {
            if (length($payload) >= 4) {
                my $idx = unpack('N', $payload);
                bf_set($peer_bf_ref, $idx);
            }

        } elsif ($id == MSG_BITFIELD) {
            $$peer_bf_ref = $payload;

        } elsif ($id == MSG_PIECE) {
            next if length($payload) < 8;
            my $idx   = unpack('N', substr($payload, 0, 4));
            my $begin = unpack('N', substr($payload, 4, 4));
            my $block = substr($payload, 8);

            if ($idx == $piece_idx && $begin + length($block) <= $plen) {
                my $block_idx = int($begin / BLOCK_SIZE);
                # Skip duplicate blocks
                next if $block_idx < $nblocks && $block_done[$block_idx];
                substr($piece_data, $begin, length($block)) = $block;
                if ($block_idx < $nblocks) {
                    $block_done[$block_idx] = 1;
                    $received++;
                }
            }
        }
    }

    return (1, $piece_data);
}

# ─── Write piece data to files (handles multi-file spanning) ─────────────────
# Uses sysseek/syswrite for thread safety (no buffering, position-independent).

sub write_piece_to_files {
    my ($piece_idx, $piece_data, $piece_length, $files, $file_handles) = @_;

    my $global_offset = $piece_idx * $piece_length;
    my $data_len      = length($piece_data);
    my $written       = 0;

    for my $i (0 .. $#$files) {
        last if $written >= $data_len;

        my $f      = $files->[$i];
        my $fstart = $f->{offset};
        my $fend   = $fstart + $f->{length};

        next if $global_offset + $written >= $fend;
        last if $global_offset + $data_len <= $fstart;

        my $write_start = ($global_offset + $written > $fstart)