File Coverage

blib/lib/Git/PurePerl/Protocol.pm

Criterion	Covered	Total	%
statement	71	77	92.2
branch	17	32	53.1
condition	3	12	25.0
subroutine	13	13	100.0
pod	0	5	0.0
total	104	139	74.8

package Git::PurePerl::Protocol;
use Moose;
use MooseX::StrictConstructor;
use Moose::Util::TypeConstraints;
use namespace::autoclean;

use Git::PurePerl::Protocol::Git;
use Git::PurePerl::Protocol::SSH;
use Git::PurePerl::Protocol::File;

has 'remote' => ( is => 'ro', isa => 'Str', required => 1 );
has 'read_socket' => ( is => 'rw', required => 0 );
has 'write_socket' => ( is => 'rw', required => 0 );

sub connect {
    my $self = shift;

    if ($self->remote =~ m{^git://(.*?@)?(.*?)(/.*)}) {
        Git::PurePerl::Protocol::Git->meta->rebless_instance(
            $self,
            hostname => $2,
            project => $3,
        );
    } elsif ($self->remote =~ m{^file://(/.*)}) {
        Git::PurePerl::Protocol::File->meta->rebless_instance(
            $self,
            path => $1,
        );
    } elsif ($self->remote =~ m{^ssh://(?:(.*?)@)?(.*?)(/.*)}
                 or $self->remote =~ m{^(?:(.*?)@)?(.*?):(.*)}) {
        Git::PurePerl::Protocol::SSH->meta->rebless_instance(
            $self,
            $1 ? (username => $1) : (),
            hostname => $2,
            path => $3,
        );
    }

    $self->connect_socket;

    my %sha1s;
    while ( my $line = $self->read_line() ) {

        # warn "S $line";
        my ( $sha1, $name ) = $line =~ /^([a-z0-9]+) ([^\0\n]+)/;

        #use YAML; warn Dump $line;
        $sha1s{$name} = $sha1;
    }
    return \%sha1s;
}

sub fetch_pack {
    my ( $self, $sha1 ) = @_;
    $self->send_line("want $sha1 side-band-64k\n");

#send_line(
#    "want 0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391 multi_ack side-band-64k ofs-delta\n"
#);
    $self->send_line('');
    $self->send_line('done');

    my $pack;

    while ( my $line = $self->read_line() ) {
        if ( $line =~ s/^\x02// ) {
            print $line;
        } elsif ( $line =~ /^NAK\n/ ) {
        } elsif ( $line =~ s/^\x01// ) {
            $pack .= $line;
        } else {
            die "Unknown line: $line";
        }

        #say "s $line";
    }
    return $pack;
}

sub send_line {
    my ( $self, $line ) = @_;
    my $length = length($line);
    if ( $length == 0 ) {
    } else {
        $length += 4;
    }

    #warn "length $length";
    my $prefix = sprintf( "%04X", $length );
    my $text = $prefix . $line;

    # warn "$text";
    $self->write_socket->print($text) || die $!;
}

sub read {
    my $self = shift;
    my $len = shift;

    my $ret = "";
    use bytes;
    while (1) {
        my $got = $self->read_socket->read( my $data, $len - length($ret));
        if (not defined $got) {
            die "error: $!";
        } elsif ( $got == 0) {
            die "EOF"
        }
        $ret .= $data;
        if (length($ret) == $len) {
            return $ret;
        }
    }
}

sub read_line {
    my $self   = shift;
    my $socket = $self->read_socket;

    my $prefix = $self->read( 4 );

    return if $prefix eq '0000';

    # warn "read prefix [$prefix]";

    my $len = 0;
    foreach my $n ( 0 .. 3 ) {
        my $c = substr( $prefix, $n, 1 );
        $len <<= 4;

        if ( $c ge '0' && $c le '9' ) {
            $len += ord($c) - ord('0');
        } elsif ( $c ge 'a' && $c le 'f' ) {
            $len += ord($c) - ord('a') + 10;
        } elsif ( $c ge 'A' && $c le 'F' ) {
            $len += ord($c) - ord('A') + 10;
        }
    }

    return $self->read( $len - 4 );
}

__PACKAGE__->meta->make_immutable;