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


line stmt bran cond sub pod time code
1             package Git::PurePerl::Protocol;
2 4     4   19 use Moose;
  4         6  
  4         30  
3 4     4   22994 use MooseX::StrictConstructor;
  4         10  
  4         32  
4 4     4   10834 use Moose::Util::TypeConstraints;
  4         11  
  4         37  
5 4     4   6981 use namespace::autoclean;
  4         12  
  4         47  
6              
7 4     4   2288 use Git::PurePerl::Protocol::Git;
  4         10  
  4         177  
8 4     4   2148 use Git::PurePerl::Protocol::SSH;
  4         12  
  4         205  
9 4     4   2174 use Git::PurePerl::Protocol::File;
  4         18  
  4         2555  
10              
11             has 'remote' => ( is => 'ro', isa => 'Str', required => 1 );
12             has 'read_socket' => ( is => 'rw', required => 0 );
13             has 'write_socket' => ( is => 'rw', required => 0 );
14              
15             sub connect {
16 1     1 0 2 my $self = shift;
17              
18 1 50 0     43 if ($self->remote =~ m{^git://(.*?@)?(.*?)(/.*)}) {
    0          
    0          
19 1         10 Git::PurePerl::Protocol::Git->meta->rebless_instance(
20             $self,
21             hostname => $2,
22             project => $3,
23             );
24             } elsif ($self->remote =~ m{^file://(/.*)}) {
25 0         0 Git::PurePerl::Protocol::File->meta->rebless_instance(
26             $self,
27             path => $1,
28             );
29             } elsif ($self->remote =~ m{^ssh://(?:(.*?)@)?(.*?)(/.*)}
30             or $self->remote =~ m{^(?:(.*?)@)?(.*?):(.*)}) {
31 0 0       0 Git::PurePerl::Protocol::SSH->meta->rebless_instance(
32             $self,
33             $1 ? (username => $1) : (),
34             hostname => $2,
35             path => $3,
36             );
37             }
38              
39 1         2307 $self->connect_socket;
40              
41 1         87 my %sha1s;
42 1         9 while ( my $line = $self->read_line() ) {
43              
44             # warn "S $line";
45 4         22 my ( $sha1, $name ) = $line =~ /^([a-z0-9]+) ([^\0\n]+)/;
46              
47             #use YAML; warn Dump $line;
48 4         16 $sha1s{$name} = $sha1;
49             }
50 1         6 return \%sha1s;
51             }
52              
53             sub fetch_pack {
54 1     1 0 2 my ( $self, $sha1 ) = @_;
55 1         6 $self->send_line("want $sha1 side-band-64k\n");
56              
57             #send_line(
58             # "want 0c7b3d23c0f821e58cd20e60d5e63f5ed12ef391 multi_ack side-band-64k ofs-delta\n"
59             #);
60 1         78 $self->send_line('');
61 1         14 $self->send_line('done');
62              
63 1         14 my $pack;
64              
65 1         5 while ( my $line = $self->read_line() ) {
66 21 100       228 if ( $line =~ s/^\x02// ) {
    100          
    50          
67 2         74 print $line;
68             } elsif ( $line =~ /^NAK\n/ ) {
69             } elsif ( $line =~ s/^\x01// ) {
70 18         526 $pack .= $line;
71             } else {
72 0         0 die "Unknown line: $line";
73             }
74              
75             #say "s $line";
76             }
77 1         134 return $pack;
78             }
79              
80             sub send_line {
81 4     4 0 7 my ( $self, $line ) = @_;
82 4         7 my $length = length($line);
83 4 100       14 if ( $length == 0 ) {
84             } else {
85 3         8 $length += 4;
86             }
87              
88             #warn "length $length";
89 4         22 my $prefix = sprintf( "%04X", $length );
90 4         10 my $text = $prefix . $line;
91              
92             # warn "$text";
93 4 50       171 $self->write_socket->print($text) || die $!;
94             }
95              
96             sub read {
97 52     52 0 54 my $self = shift;
98 52         42 my $len = shift;
99              
100 52         113 my $ret = "";
101 4     4   33 use bytes;
  4         7  
  4         33  
102 52         49 while (1) {
103 52         1853 my $got = $self->read_socket->read( my $data, $len - length($ret));
104 52 50       536157 if (not defined $got) {
    50          
105 0         0 die "error: $!";
106             } elsif ( $got == 0) {
107 0         0 die "EOF"
108             }
109 52         196 $ret .= $data;
110 52 50       138 if (length($ret) == $len) {
111 52         216 return $ret;
112             }
113             }
114             }
115              
116             sub read_line {
117 27     27 0 46 my $self = shift;
118 27         1241 my $socket = $self->read_socket;
119              
120 27         61 my $prefix = $self->read( 4 );
121              
122 27 100       73 return if $prefix eq '0000';
123              
124             # warn "read prefix [$prefix]";
125              
126 25         32 my $len = 0;
127 25         55 foreach my $n ( 0 .. 3 ) {
128 100         141 my $c = substr( $prefix, $n, 1 );
129 100         74 $len <<= 4;
130              
131 100 100 66     414 if ( $c ge '0' && $c le '9' ) {
    50 33        
    0 0        
132 92         137 $len += ord($c) - ord('0');
133             } elsif ( $c ge 'a' && $c le 'f' ) {
134 8         35 $len += ord($c) - ord('a') + 10;
135             } elsif ( $c ge 'A' && $c le 'F' ) {
136 0         0 $len += ord($c) - ord('A') + 10;
137             }
138             }
139              
140 25         83 return $self->read( $len - 4 );
141             }
142              
143             __PACKAGE__->meta->make_immutable;